home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / DB_CLIPP / 0327.ZIP / DB3.PAS < prev    next >
Pascal/Delphi Source File  |  1986-09-10  |  22KB  |  637 lines

  1.   (*
  2.   Turbo Pascal routines to access dBASE III [+] files
  3.   By J. Troutman <JT> CompuServe PPN 74746,1567
  4.   Revision history
  5.    Version 1.1  - enhancements to cause the header to be updated
  6.                   when changing the .DBF file and to ensure that the
  7.                   End Of File marker is written and to simplify use
  8.                   5/6/86
  9.            1.2  - cleans up (some of) the absurdities in the code and
  10.                   allocates the current record buffer on the heap rather than
  11.                   in the data segment.  A few comments added and a few symbol
  12.                   names changed. Error checking has been improved with the
  13.                   addition of two global status variables.
  14.                   5/27/86
  15.  
  16.                     !!!!ATTENTION!!!!
  17.   If you have downloaded an earlier version of this file, please note that
  18.   several of the TYPEs and VARs have been changed.  You will have to make
  19.   some adjustments to any existing programs you have that use these routines.
  20.   Why have they been changed?  Several have been changed to decrease the
  21.   data segment storage demands of the code (declaring some variables as
  22.   pointers, for example); others in order to avoid conflicts with any
  23.   Types and Variables your program might define.
  24.  
  25.   The routines in this file present some tools for accessing dBASE III and
  26.   dBASE III Plus files from within a Turbo Pascal program.  There is MUCH
  27.   room for improvement: the error checking is simplistic, there are no routines
  28.   to access memo files, no buffering of data, no support for index files,
  29.   etc. The main routines are:
  30.  
  31.          PROCEDURE OpenDbf(VAR D : dbfRecord;) : Integer;
  32.          PROCEDURE CloseDbf(VAR D : dbfRecord) : Integer;
  33.          PROCEDURE GetDbfRecord(VAR D : dbfRecord; RecNum : Real);
  34.          PROCEDURE PutDbfRecord(VAR D : dbfRecord; RecNum : Real);
  35.          PROCEDURE AppendDbf(VAR D : dbfRecord);
  36.  
  37.   The error checking has been improved somewhat in this version with the
  38.   addition of two global variables: dbfOK and dbfError. After calling one of
  39.   the procedures, checking the status of the Boolean variable dbfOK will
  40.   reveal the success or failure of the operation.  If it failed, the Integer
  41.   variable dbfError will contain a value corresponding to the IOResult value or
  42.   to a specially assigned value for several special conditions.  Notice in
  43.   particular that an unsuccessful call to CloseDbf will leave the file status
  44.   unchanged and the memory still allocated.  It is your program's
  45.   responsibility to take appropriate action.  OpenDbf and CloseDbf have
  46.   now become procedures.
  47.  
  48.   A skeletal program might go something like:
  49.     VAR
  50.       D : dbfRecord; { declare your dBASE file variable }
  51.     BEGIN
  52.     {...initialize and get filename of .dbf file into FileName field
  53.        of D variable ...  }
  54.     OpenDbf(D);        { to open the file }
  55.     IF NOT dbfOK THEN { check dbfError and process error };
  56.     {... the rest of your program including calls to
  57.      GetDbfRecord, PutDbfRecord, AppendDbf as needed
  58.      always remembering to interrogate the two global status
  59.      variables after each procedure call   }
  60.     CloseDbf (D);      { to close the file  }
  61.     IF NOT dbfOK THEN { check dbfError and process error };
  62.     END.
  63.  
  64.   Upon exit from the GetDbfRecord Procedure, the CurRecord of the
  65.   dbfRecord variable points to the current record contents.  Each field
  66.   can be accessed using its offset into the CurRecord^ with the variable
  67.   Off in the Fields^ array.
  68.   Upon entry to the PutDbfRecord Procedure, the CurRecord^ should contain
  69.   the data that you want to write.
  70.   AppendDbf automatically adds a record to the end of the file (the
  71.   CurRecord^ should contain the data that you want to write).
  72.  
  73.   Notice that the OpenDbf routine does allocate a buffer on the heap for
  74.   the current record.  You can, of course, override this by pointing
  75.   CurRecord to any data structure that you wish.
  76.  
  77.   See the demo program for some examples.
  78.   If you should have any problems with these routines, please leave me a
  79.   note.
  80.   *)
  81.  
  82. (*
  83. dBASE III Database File Structure
  84. The structure of a dBASE III database file is composed of a
  85. header and data records.  The layout is given below.
  86. dBASE III DATABASE FILE HEADER:
  87. +---------+-------------------+---------------------------------+
  88. |  BYTE   |     CONTENTS      |          MEANING                |
  89. +---------+-------------------+---------------------------------+
  90. |  0      |  1 byte           | dBASE III version number        |
  91. |         |                   |  (03H without a .DBT file)      |
  92. |         |                   |  (83H with a .DBT file)         |
  93. +---------+-------------------+---------------------------------+
  94. |  1-3    |  3 bytes          | date of last update             |
  95. |         |                   |  (YY MM DD) in binary format    |
  96. +---------+-------------------+---------------------------------+
  97. |  4-7    |  32 bit number    | number of records in data file  |
  98. +---------+-------------------+---------------------------------+
  99. |  8-9    |  16 bit number    | length of header structure      |
  100. +---------+-------------------+---------------------------------+
  101. |  10-11  |  16 bit number    | length of the record            |
  102. +---------+-------------------+---------------------------------+
  103. |  12-31  |  20 bytes         | reserved bytes (version 1.00)   |
  104. +---------+-------------------+---------------------------------+
  105. |  32-n   |  32 bytes each    | field descriptor array          |
  106. |         |                   |  (see below)                    | --+
  107. +---------+-------------------+---------------------------------+   |
  108. |  n+1    |  1 byte           | 0DH as the field terminator     |   |
  109. +---------+-------------------+---------------------------------+   |
  110. |
  111. |
  112. A FIELD DESCRIPTOR:      <------------------------------------------+
  113. +---------+-------------------+---------------------------------+
  114. |  BYTE   |     CONTENTS      |          MEANING                |
  115. +---------+-------------------+---------------------------------+
  116. |  0-10   |  11 bytes         | field name in ASCII zero-filled |
  117. +---------+-------------------+---------------------------------+
  118. |  11     |  1 byte           | field type in ASCII             |
  119. |         |                   |  (C N L D or M)                 |
  120. +---------+-------------------+---------------------------------+
  121. |  12-15  |  32 bit number    | field data address              |
  122. |         |                   |  (address is set in memory)     |
  123. +---------+-------------------+---------------------------------+
  124. |  16     |  1 byte           | field length in binary          |
  125. +---------+-------------------+---------------------------------+
  126. |  17     |  1 byte           | field decimal count in binary   |
  127. +---------+-------------------+--------------------------------
  128. |  18-31  |  14 bytes         | reserved bytes (version 1.00)   |
  129. +---------+-------------------+---------------------------------+
  130. The data records are layed out as follows:
  131. 1. Data records are preceeded by one byte that is a
  132. space (20H) if the record is not deleted and an
  133. asterisk (2AH) if it is deleted.
  134. 2. Data fields are packed into records with no field
  135. separators or record terminators.
  136. 3. Data types are stored in ASCII format as follows:
  137. DATA TYPE      DATA RECORD STORAGE
  138. ---------      --------------------------------------------
  139. Character      (ASCII characters)
  140. Numeric        - . 0 1 2 3 4 5 6 7 8 9
  141. Logical        ? Y y N n T t F f  (? when not initialized)
  142. Memo           (10 digits representing a .DBT block number)
  143. Date           (8 digits in YYYYMMDD format, such as
  144. 19840704 for July 4, 1984)
  145.  
  146. This information came directly from the Ashton-Tate Forum.
  147. It can also be found in the Advanced Programmer's Guide available
  148. from Ashton-Tate.
  149. *)
  150.  
  151. CONST
  152.   DB3File = 3;
  153.   DB3WithMemo = $83;
  154.   ValidTypes : SET OF Char = ['C', 'N', 'L', 'M', 'D'];
  155.   MAX_HEADER = 4129;          { = maximum length of dBASE III header }
  156.   MAX_BYTES_IN_RECORD = 4000; { dBASE III record limit }
  157.   MAX_FIELDS_IN_RECORD = 128; { dBASE III field limit  }
  158.   BYTES_IN_MEMO_RECORD = 512; { dBASE III memo field record size }
  159.  
  160.   { Special Error codes for .DBF files }
  161.   NOT_DB_FILE = $80;  { indicates the first byte was not a $3 or $83 }
  162.   INVALID_FIELD = $81;{ an invalid field type was found }
  163.   REC_TOO_HIGH = $82; { tried to read a record beyond the correct range }
  164.  
  165.   (*
  166.   Although there are some declarations for memo files, the routines to access
  167.   them have not been implemented.
  168.   *)
  169.  
  170. TYPE
  171.   _HeaderType = ARRAY[0..MAX_HEADER] OF Byte;
  172.   _HeaderPrologType = ARRAY[0..31] OF Byte; { dBASE III header prolog }
  173.   _FieldDescType = ARRAY[0..31] OF Byte; { dBASE III field definitions }
  174.   _dRec = ^_DataRecord;
  175.   _DataRecord = ARRAY[0..MAX_BYTES_IN_RECORD] OF Byte; {the 0 offset represents
  176.                                                       the 'deleted' flag.   }
  177.   _Str255 = STRING[255];
  178.   _Str80 = STRING[80];
  179.   _Str64 = STRING[64];
  180.   _Str10 = STRING[10];
  181.   _Str8 = STRING[8];
  182.   _Str2 = STRING[2];
  183.   _dbfFile = FILE;
  184.   _FieldRecord = RECORD
  185.                   Name : _Str10;
  186.                   Typ : Char;
  187.                   Len : Byte;
  188.                   Dec : Byte;
  189.                   Off : Integer;
  190.                 END;
  191.   _FieldArray = ARRAY[1..MAX_FIELDS_IN_RECORD] OF _FieldRecord;
  192.   _dFields = ^_FieldArray;
  193.   _MemoRecord = ARRAY[1..BYTES_IN_MEMO_RECORD] OF Byte;
  194.   _MemoFile = FILE OF _MemoRecord;
  195.   _StatusType = (NotOpen, NotUpdated, Updated);
  196.   dbfRecord = RECORD
  197.                 FileName : _Str64;
  198.                 dFile : _dbfFile;
  199.                 HeadProlog : _HeaderPrologType;
  200.                 dStatus : _StatusType;
  201.                 WithMemo : Boolean;
  202.                 DateOfUpdate : _Str8;
  203.                 NumRecs : Real;
  204.                 HeadLen : Integer;
  205.                 RecLen : Integer;
  206.                 NumFields : Integer;
  207.                 Fields : _dFields;
  208.                 CurRecord : _dRec;
  209.               END;
  210.  
  211.   (*
  212.   Notice that if you need to access more than one .DBF file simultaneously
  213.   you could declare an ARRAY of dbfRecord.
  214.   *)
  215.   VAR
  216.     dbfError : Integer; { global error indicators }
  217.     dbfOK  : Boolean;
  218.  
  219.   FUNCTION MakeReal(VAR b) : Real;
  220.     { takes a long 32-bit integer and converts it to a real }
  221.  
  222.   VAR
  223.     r : ARRAY[1..4] OF Byte ABSOLUTE b;
  224.  
  225.   BEGIN
  226.   MakeReal := (r[1]*1)+(r[2]*256)+(r[3]*65536.0)+(r[4]*16777216.0);
  227.   END;
  228.  
  229.   FUNCTION MakeInt(VAR b) : Integer;
  230.   VAR
  231.     i : Integer ABSOLUTE b;
  232.  
  233.   BEGIN
  234.   MakeInt := i;
  235.   END;
  236.  
  237.   FUNCTION MakeStr(b : Byte) : _Str2;
  238.   VAR
  239.     i : Integer;
  240.     s : _Str2;
  241.   BEGIN
  242.   i := b;
  243.   Str(i:2, s);
  244.   MakeStr := s;
  245.   END;
  246.  
  247.   PROCEDURE GetDbfRecord(VAR D : dbfRecord; RecNum : Real);
  248.  
  249.   VAR
  250.     Result : Integer;
  251.  
  252.   BEGIN
  253.   IF RecNum > D.NumRecs THEN
  254.     BEGIN
  255.     dbfError := REC_TOO_HIGH;
  256.     dbfOK := FALSE;
  257.     Exit;
  258.     END;
  259.   {$I-} LongSeek(D.dFile, D.HeadLen+(RecNum-1)*D.RecLen); {$I+}
  260.   dbfError := IOResult;
  261.   dbfOK := (dbfError = 0);
  262.   IF dbfOK THEN
  263.     BEGIN
  264.     {$I-} BlockRead(D.dFile, D.CurRecord^, D.RecLen, Result); {$I+}
  265.     dbfError := IOResult;
  266.     dbfOK := (dbfError = 0);
  267.     END;
  268.   END;                        {GetDbfRecord}
  269.  
  270.   PROCEDURE PutDbfRecord(VAR D : dbfRecord; RecNum : Real);
  271.  
  272.   VAR
  273.     Result : Integer;
  274.  
  275.   BEGIN
  276.   IF RecNum > D.NumRecs THEN
  277.     BEGIN
  278.     RecNum := D.NumRecs+1;
  279.     D.NumRecs := RecNum;
  280.     END;
  281.   {$I-} LongSeek(D.dFile, D.HeadLen+(RecNum-1)*D.RecLen); {$I+}
  282.   dbfError := IOResult;
  283.   dbfOK := (dbfError = 0);
  284.   IF dbfOK THEN
  285.     BEGIN
  286.     {$I-} BlockWrite(D.dFile, D.CurRecord^, D.RecLen, Result); {$I+}
  287.     dbfError := IOResult;
  288.     dbfOK := (dbfError = 0);
  289.     END;
  290.   IF dbfOK THEN D.dStatus := Updated;
  291.   END;                        {PutDbfRecord}
  292.  
  293.   PROCEDURE AppendDbf(VAR D : dbfRecord);
  294.  
  295.   BEGIN
  296.   PutDbfRecord(D, D.NumRecs+1);
  297.   END;
  298.  
  299.   PROCEDURE CloseDbf(VAR D : dbfRecord);
  300.  
  301.     PROCEDURE UpdateHeader;
  302.  
  303.     TYPE
  304.       RegType = RECORD CASE Byte OF
  305.         1 : (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer);
  306.         2 : (AL, AH, BL, BH, CL, CH, DL, DH : Byte);
  307.                 END;
  308.  
  309.     VAR
  310.       Reg : RegType;
  311.       r : Real;
  312.  
  313.     BEGIN                     { UpdateHeader }
  314.     Reg.AX := $2A00;          { Get DOS Date }
  315.     Intr($21, Reg);
  316.     D.HeadProlog[1] := Reg.CX-1900; {Year}
  317.     D.HeadProlog[2] := Reg.DH; {Month}
  318.     D.HeadProlog[3] := Reg.DL; {Day}
  319.     r := D.NumRecs;
  320.     D.HeadProlog[7] := Trunc(r/16777216.0);
  321.     r := r-(D.HeadProlog[7]*16777216.0);
  322.     D.HeadProlog[6] := Trunc(r/65536.0);
  323.     r := r-(D.HeadProlog[6]*65536.0);
  324.     D.HeadProlog[5] := Trunc(r/256);
  325.     r := r-(D.HeadProlog[5]*256);
  326.     D.HeadProlog[4] := Trunc(r);
  327.     {$I-}LongSeek(D.dFile, 0);{$I+}
  328.     dbfError := IOResult;
  329.     dbfOK := (dbfError = 0);
  330.     IF dbfOK THEN
  331.       BEGIN
  332.       {$I-} BlockWrite(D.dFile, D.HeadProlog, SizeOf(D.HeadProlog)); {$I+}
  333.       dbfError := IOResult;
  334.       dbfOK := (dbfError = 0);
  335.       END;
  336.     END;                      { UpdateHeader }
  337.  
  338.   CONST
  339.     EofMark : Byte = $1A;
  340.  
  341.   BEGIN                       { CloseDbf }
  342.   dbfOK := TRUE;
  343.   IF D.dStatus = Updated THEN
  344.     BEGIN
  345.     UpdateHeader;
  346.     IF dbfOK THEN
  347.       BEGIN
  348.       {$I-} LongSeek(D.dFile, D.HeadLen+D.NumRecs*D.RecLen); {$I+}
  349.       dbfError := IOResult;
  350.       dbfOK := (dbfError = 0);
  351.       END;
  352.     IF dbfOK THEN
  353.       BEGIN
  354.       {$I-} BlockWrite(D.dFile, EofMark, 1); {$I+} {Put EOF marker }
  355.       dbfError := IOResult;
  356.       dbfOK := (dbfError = 0);
  357.       END;
  358.     END;   { IF Updated }
  359.   IF dbfOK THEN
  360.     BEGIN
  361.     {$I-} Close(D.dFile);     {$I+}
  362.     dbfError := IOResult;
  363.     dbfOK := (dbfError = 0);
  364.     END;
  365.   IF dbfOK THEN
  366.     BEGIN
  367.       D.dStatus := NotOpen;
  368.       FreeMem(D.CurRecord, D.RecLen);
  369.       FreeMem(D.Fields, D.NumFields*SizeOf(_FieldRecord));
  370.     END;
  371.   END;                        { CloseDbf }
  372.  
  373.   PROCEDURE OpenDbf(VAR D : dbfRecord);
  374.  
  375.     PROCEDURE ProcessHeader(VAR Header : _HeaderType; NumBytes : Integer);
  376.  
  377.       PROCEDURE GetOneFieldDesc(VAR F; VAR Field : _FieldRecord;
  378.                                 VAR Offset : Integer);
  379.  
  380.       VAR
  381.         i : Integer;
  382.         FD : _FieldDescType ABSOLUTE F;
  383.  
  384.       BEGIN                   { GetOneFieldDesc }
  385.       i := 0;
  386.       Field.Name := '          ';
  387.       REPEAT
  388.         Field.Name[Succ(i)] := Chr(FD[i]);
  389.         i := Succ(i);
  390.       UNTIL FD[i] = 0;
  391.       Field.Name[0] := Chr(i);
  392.       Field.Typ := Char(FD[11]);
  393.       Field.Len := FD[16];
  394.       Field.Dec := FD[17];
  395.       Field.Off := Offset;
  396.       Offset := Offset+Field.Len;
  397.       IF NOT(Field.Typ IN ValidTypes) THEN
  398.         dbfError := INVALID_FIELD;
  399.       END;                    { GetOneFieldDesc }
  400.  
  401.     VAR
  402.       o, i, tFieldsLen : Integer;
  403.       tempFields : _FieldArray;
  404.  
  405.     BEGIN                     {ProcessHeader}
  406.     CASE Header[0] OF
  407.       DB3File : D.WithMemo := False;
  408.       DB3WithMemo : D.WithMemo := True;
  409.       ELSE
  410.         BEGIN
  411.         dbfError := NOT_DB_FILE;
  412.         Close(D.dFile);
  413.         Exit;
  414.         END;
  415.       END;                      {CASE}
  416.     D.DateOfUpdate := MakeStr(Header[2])+'/'+MakeStr(Header[3])+'/'+MakeStr(Header[1]);
  417.     D.NumRecs := MakeReal(Header[4]);
  418.     D.HeadLen := MakeInt(Header[8]);
  419.     IF NumBytes < D.HeadLen THEN
  420.       BEGIN
  421.       dbfError := NOT_DB_FILE;
  422.       Close(D.dFile);
  423.       Exit;
  424.       END;
  425.     D.RecLen := MakeInt(Header[10]); { Includes the Deleted Record Flag }
  426.     GetMem(D.CurRecord, D.RecLen); { Allocate some memory for a buffer  }
  427.     D.dStatus := NotUpdated;
  428.     D.NumFields := 0;
  429.     Move(Header, D.HeadProlog, SizeOf(D.HeadProlog));
  430.     o := 1;                   {Offset within dbf record of current field }
  431.     i := 32;                  {Index for Header }
  432.     WHILE Header[i] <> $0D DO
  433.       BEGIN
  434.       D.NumFields := Succ(D.NumFields);
  435.       GetOneFieldDesc(Header[i], tempFields[D.NumFields], o);
  436.       IF dbfError <> 0 THEN
  437.         BEGIN
  438.         Close(D.dFile);
  439.         Exit;
  440.         END;
  441.       i := i+32;
  442.       END;                    { While Header[i] <> $0D }
  443.     tFieldsLen := D.NumFields*SizeOf(_FieldRecord);
  444.     GetMem(D.Fields, tFieldsLen);
  445.     Move(tempFields, D.Fields^, tFieldsLen);
  446.     IF Header[Succ(D.HeadLen)] = 0 THEN D.HeadLen := Succ(D.HeadLen);
  447.     END;                      {ProcessHeader}
  448.  
  449.     PROCEDURE GetHeader;
  450.  
  451.     VAR
  452.       Result : Integer;
  453.       H : _HeaderType;
  454.  
  455.     BEGIN                     { GetHeader }
  456.     {$I-} BlockRead(D.dFile, H, MAX_HEADER, Result); {$I+}
  457.     dbfError := IOResult;
  458.     IF dbfError = 0 THEN ProcessHeader(H, Result);
  459.     END;                      { GetHeader }
  460.  
  461.   BEGIN                       { OpenDbf }
  462.   Assign(D.dFile, D.FileName);
  463.   {$I-} Reset(D.dFile, 1); {$I+} {the '1' parameter sets the record size}
  464.   dbfError := IOResult;
  465.   IF dbfError = 0 THEN GetHeader;
  466.   dbfOK := (dbfError = 0);
  467.   END;                        { OpenDbf }
  468.  
  469. (* !!!!!!!!! To enable the Demo program, delete the next line.  !!!!!!!!! *)
  470. (*
  471.  
  472.   PROCEDURE ErrorHalt(errorCode : Integer);
  473.     { a VERY crude error handler }
  474.   VAR
  475.     errorMsg : _Str80;
  476.  
  477.   BEGIN
  478.   CASE errorCode OF
  479.      00 : Exit;                { no error occurred }
  480.     $01 : errorMsg := 'Not found';
  481.     $02 : errorMsg := 'Not open for input';
  482.     $03 : errorMsg := 'Not open for output';
  483.     $04 : errorMsg := 'Just not open';
  484.     $91 : errorMsg := 'Seek beyond EOF';
  485.     $99 : errorMsg := 'Unexpected EOF';
  486.     $F0 : errorMsg := 'Disk write error';
  487.     $F1 : errorMsg := 'Directory full';
  488.     $F3 : errorMsg := 'Too many files';
  489.     $FF : errorMsg := 'Where did that file go?';
  490.     NOT_DB_FILE : errorMsg := 'Not a dBASE data file';
  491.     INVALID_FIELD : errorMsg := 'Invalid field type encountered';
  492.     REC_TOO_HIGH  : errorMsg := 'Requested record beyond range';
  493.     ELSE
  494.      errorMsg := 'Undefined error';
  495.     END;
  496.   WriteLn;
  497.   WriteLn(errorMsg);
  498.   Halt(1);
  499.   END;
  500.  
  501. TYPE
  502.   PseudoStr = ARRAY[1..255] OF Char;
  503.  
  504. VAR
  505.   Demo : dbfRecord;
  506.   j, i : Integer;
  507.   blanks : _Str255;
  508.   SizeOfFile, r : Real;
  509.   fn : _Str64;
  510.  
  511.   PROCEDURE Wait;
  512.   VAR
  513.     c : Char;
  514.  
  515.   BEGIN
  516.   Write('Press any key to continue . . .');
  517.   Read(Kbd, c);
  518.   END;
  519.  
  520.  
  521.   PROCEDURE List(VAR D : dbfRecord);
  522.  
  523.     PROCEDURE ShowField(VAR a; VAR F : _FieldRecord);
  524.  
  525.     VAR
  526.       Data : PseudoStr ABSOLUTE a;
  527.  
  528.     BEGIN
  529.     WITH F DO
  530.       BEGIN
  531.       CASE Typ OF
  532.         'C', 'N', 'L' : Write(Copy(Data, 1, Len));
  533.         'M' : Write('Memo      ');
  534.         'D' : Write(Copy(Data, 5, 2), '/',
  535.               Copy(Data, 7, 2), '/',
  536.               Copy(Data, 1, 2));
  537.       END;                    {CASE}
  538.       IF Len <= Length(Name) THEN
  539.         Write(Copy(blanks, 1, Length(Name)-Pred(Len)))
  540.       ELSE
  541.         Write(' ');
  542.       END;                    {WITH F}
  543.     END;                      {ShowField}
  544.  
  545.   BEGIN                       {List}
  546.   WriteLn;
  547.   Write('Rec Num  ');
  548.   WITH D DO
  549.     BEGIN
  550.     FOR i := 1 TO NumFields DO
  551.       WITH Fields^[i] DO
  552.         IF Len >= Length(Name) THEN
  553.           Write(Name, Copy(blanks, 1, Succ(Len-Length(Name))))
  554.         ELSE
  555.           Write(Name, ' ');
  556.     WriteLn;
  557.     r := 1;
  558.     WHILE r <= NumRecs DO
  559.       BEGIN
  560.       GetDbfRecord(Demo, r);
  561.       IF NOT dbfOK THEN ErrorHalt(dbfError);
  562.       WriteLn;
  563.       Write(r:7:0, ' ');
  564.       Write(Chr(CurRecord^[0])); { the 'deleted' indicator }
  565.       FOR i := 1 TO NumFields DO
  566.         ShowField(CurRecord^[Fields^[i].Off], Fields^[i]);
  567.       r := r+1;
  568.       END;                    {WHILE r }
  569.     END;                      {WITH D }
  570.   END;                        {List}
  571.  
  572.   PROCEDURE DisplayStructure(VAR D : dbfRecord);
  573.  
  574.   VAR
  575.     i : Integer;
  576.  
  577.   BEGIN
  578.   WITH D DO
  579.     BEGIN
  580.     ClrScr;
  581.     Write(' #  Field Name   Type  Length  Decimal');
  582.     FOR i := 1 TO NumFields DO
  583.       BEGIN
  584.       WITH Fields^[i] DO
  585.         BEGIN
  586.         IF i MOD 20 = 0 THEN
  587.           BEGIN
  588.           WriteLn;
  589.           Wait;
  590.           ClrScr;
  591.           Write(' #  Field Name   Type  Length  Decimal');
  592.           END;
  593.         GoToXY(1, Succ(WhereY));
  594.         Write(i:2, Name:12, Typ:5, Len:9);
  595.         IF Typ = 'N' THEN Write(Dec:5);
  596.         END;                  {WITH Fields^}
  597.       END;                    {FOR}
  598.     WriteLn;
  599.     Wait;
  600.     END;                      {WITH D}
  601.   END;                        { DisplayStructure }
  602.  
  603.  
  604. BEGIN                         {Demonstration of DBF routines}
  605. WITH Demo DO
  606.   BEGIN
  607.   FillChar(blanks, SizeOf(blanks), $20);
  608.   blanks[0] := Chr(255);
  609.   ClrScr;
  610.   GoToXY(10, 10);
  611.   Write('Name of dBASE file (.DBF assumed): ');
  612.   Read(FileName);
  613.   IF Pos('.', FileName) = 0 THEN FileName := FileName+'.DBF';
  614.   OpenDbf(Demo);
  615.   IF NOT dbfOK THEN ErrorHalt(dbfError);
  616.   ClrScr;
  617.   SizeOfFile := LongFileSize(dFile);
  618.   WriteLn('File Name: ', FileName);
  619.   WriteLn('Date Of Last Update: ', DateOfUpdate);
  620.   WriteLn('Number of Records: ', NumRecs:10:0);
  621.   WriteLn('Size of File: ', SizeOfFile:15:0);
  622.   WriteLn('Length of Header: ', HeadLen:11);
  623.   WriteLn('Length of One Record: ', RecLen:7);
  624.   IF WithMemo THEN WriteLn('This file contains Memo fields.');
  625.   Wait;
  626.   ClrScr;
  627.   DisplayStructure(Demo);
  628.   ClrScr;
  629.   List(Demo);
  630.   WriteLn;
  631.   Wait;
  632.   CloseDbf(Demo);
  633.   IF NOT dbfOK THEN ErrorHalt(dbfError);
  634.   END;                        {WITH}
  635. END.                          {of Demo program }
  636. *)
  637.